home *** CD-ROM | disk | FTP | other *** search
- unit Lcklist;
-
- interface
-
- uses
- SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
- Forms, Dialogs, Menus, Grids, DbiTypes, DbiProcs, DbiErrs, DB, DBTables,
- LockInfo, Buttons, StdCtrls, ExtCtrls;
-
- const LockStr: array[0..9] of string[30] = ('Record lock (write)',
- 'Record lock (read)',
- 'Paradox Group lock',
- 'Paradox Image lock',
- 'Table open lock',
- 'Table read lock',
- 'Table write lock',
- 'Exclusive lock',
- 'Error!',
- 'Unknown lock');
-
- Titles: array[0..5] of string[14] = ('LOCKTYPE', 'USERNAME', 'NETSESSION',
- 'OURSESSION', 'RECORDNUM', 'COUNT');
-
- type
- TLockTypes = (lkRecordWrite, lkRecordRead, lkPdoxGroup, lkPdoxImage,
- lkOpen, lkRead, lkWrite, lkExcl, lkError, lkUnknown);
-
- TFrmLocks = class(TForm)
- LocksList: TStringGrid;
- Table1: TTable;
- Panel1: TPanel;
- Edit2: TEdit;
- Edit3: TEdit;
- Edit4: TEdit;
- Edit5: TEdit;
- SpeedButton1: TSpeedButton;
- SpeedButton2: TSpeedButton;
- CheckBox1: TCheckBox;
- CheckBox2: TCheckBox;
- CheckBox3: TCheckBox;
- CheckBox4: TCheckBox;
- CheckBox5: TCheckBox;
- Panel2: TPanel;
- SpeedButton3: TSpeedButton;
- SpeedButton4: TSpeedButton;
- ComboBox1: TComboBox;
- SpeedButton5: TSpeedButton;
- Edit6: TEdit;
- Label1: TLabel;
- SpeedButton6: TSpeedButton;
- cboLockType: TComboBox;
- procedure ExitApp(Sender: TObject);
- procedure ShowLocksList(Sender: TObject);
- procedure FormCreate(Sender: TObject);
- procedure FormDestroy(Sender: TObject);
- procedure SpeedButton1Click(Sender: TObject);
- procedure SpeedButton2Click(Sender: TObject);
- procedure CheckBox1Click(Sender: TObject);
- procedure ComboBox1Change(Sender: TObject);
- procedure SpeedButton5Click(Sender: TObject);
- procedure SpeedButton6Click(Sender: TObject);
- private
- { Private declarations }
- FCursor: HDbiCur;
- procedure OpenLocksList;
- public
- { Public declarations }
- LckSrch: TLocksList;
- procedure SetCursor(ATable: TTable);
- end;
-
- var
- FrmLocks: TFrmLocks;
-
-
- implementation
-
- uses RLocks;
-
- {$R *.DFM}
-
- procedure TFrmLocks.SetCursor(ATable: TTable);
- begin
- if ATable.State = dsInactive then
- raise Exception.Create('Table must be open');
- FCursor := ATable.Handle;
- end;
-
- procedure TFrmLocks.OpenLocksList;
- var NRecs: LongInt;
- LckDesc: LOCKDesc;
- LckCur: HDbiCur;
- CellRow: Byte;
- Props: CURProps;
- UserName: string;
- begin
- Check(DbiOpenLockList(FCursor, True, True, LckCur));
- Check(DbiGetCursorProps(LckCur, Props));
- Check(DbiSetProp(HDBIObj(FCursor), curXLTMODE, LongInt(xltFIELD)));
- Check(DbiGetCursorProps(LckCur, Props));
- try
- Check(DbiGetRecordCount(LckCur, NRecs));
- if NRecs > 0 then
- begin
- LocksList.RowCount := Succ(NRecs);
- CellRow := 1;
- while (DbiGetNextRecord(LckCur, dbiNOLOCK, @LckDesc, nil) = DBIERR_NONE) do
- with LocksList, LckDesc do
- begin
- Cells[0, CellRow] := LockStr[iType];
- NativeToAnsi(Table1.Locale, szUserName, Username);
- Cells[1, CellRow] := UserName;
- Cells[2, CellRow] := IntToStr(iNetSession);
- Cells[3, CellRow] := IntToStr(iSession);
- Cells[4, CellRow] := IntToStr(iRecNum);
- Cells[5, CellRow] := IntToStr(iInfo);
- Inc(CellRow);
- end;
- end;
- finally
- Check(DbiCloseCursor(LckCur));
- end;
- end;
-
- procedure TFrmLocks.ExitApp(Sender: TObject);
- begin
- Close;
- end;
-
- procedure TFrmLocks.ShowLocksList(Sender: TObject);
- begin
- SetCursor(Table1);
- OpenLocksList;
- end;
-
- procedure TFrmLocks.FormCreate(Sender: TObject);
- var i: Byte;
- begin
- with cboLockType do
- begin
- for i := 0 to 9 do
- Items[i] := LockStr[i];
- ItemIndex := 0;
- end;
-
- for i := 0 to 5 do
- with LocksList do
- begin
- Cells[i, 0] := Titles[i];
- ColWidths[i]:= Canvas.TextWidth(Titles[i]);
- end;
- LocksList.ColWidths[0] := Canvas.TextWidth(LockStr[3]) + 5;
- Session.GetTableNames('DBDEMOS', '', True, False, Combobox1.Items);
- with ComboBox1 do
- ItemIndex := Items.IndexOf(Table1.TableName);
-
- Table1.Open;
- LckSrch := TLocksList.Create;
- LckSrch.Table := Table1;
- end;
-
- procedure TFrmLocks.FormDestroy(Sender: TObject);
- begin
- LckSrch.free;
- end;
-
- procedure TFrmLocks.SpeedButton1Click(Sender: TObject);
- var ld: LOCKDesc;
- begin
- with cboLockType do
- LckSrch.SetParams(TLockType(ItemIndex), Edit2.Text, StrToInt(Edit3.Text),
- StrToInt(Edit4.Text), StrToInt(Edit5.Text));
- if not LckSrch.findfirst(ld) then
- showmessage('Failed - no lock found')
- else
- showmessage('OK - found the lock!');
- end;
-
- procedure TFrmLocks.SpeedButton2Click(Sender: TObject);
- var ld: LOCKDesc;
- begin
- if not LckSrch.findnext(ld) then
- showmessage('Failed - no lock found')
- else
- showmessage('OK - found the lock!');
- end;
-
- procedure TFrmLocks.CheckBox1Click(Sender: TObject);
- var opts: TLookFor;
- begin
- opts := LckSrch.Lookfor;
- with Sender As TCheckBox do
- if Checked then Include(opts, TLockInfoType(Tag))
- else Exclude(opts, TLockInfoType(Tag));
- LckSrch.Lookfor := opts;
- end;
-
- procedure TFrmLocks.ComboBox1Change(Sender: TObject);
- begin
- Table1.Close;
- Table1.TableName := ComboBox1.Text;
- Table1.Open;
- end;
-
- procedure TFrmLocks.SpeedButton5Click(Sender: TObject);
- var UName, Msg: string;
- begin
- UName := GetLockUser(Table1, StrToInt(Edit6.Text));
-
- if UName = '' then Msg := 'Record not locked'
- else Msg := 'Record locked by user ' + UName;
- MessageDlg(Msg, mtInformation, [mbOK], 0);
- end;
-
- procedure TFrmLocks.SpeedButton6Click(Sender: TObject);
- begin
- Form1.Show;
- end;
-
- end.
-